home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / OldSrc / CH4 / SRC / ENLARGEF.FRM (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1997-01-03  |  14.9 KB  |  489 lines

  1. VERSION 4.00
  2. Begin VB.Form EnlargeForm 
  3.    Caption         =   "Enlarge"
  4.    ClientHeight    =   4650
  5.    ClientLeft      =   420
  6.    ClientTop       =   1185
  7.    ClientWidth     =   8955
  8.    Height          =   5340
  9.    Left            =   360
  10.    LinkTopic       =   "Form1"
  11.    ScaleHeight     =   310
  12.    ScaleMode       =   3  'Pixel
  13.    ScaleWidth      =   597
  14.    Top             =   555
  15.    Width           =   9075
  16.    Begin VB.PictureBox Pict 
  17.       AutoRedraw      =   -1  'True
  18.       BackColor       =   &H00C0C0C0&
  19.       Height          =   4440
  20.       Index           =   2
  21.       Left            =   6000
  22.       Picture         =   "ENLARGEF.frx":0000
  23.       ScaleHeight     =   292
  24.       ScaleMode       =   3  'Pixel
  25.       ScaleWidth      =   192
  26.       TabIndex        =   2
  27.       Top             =   0
  28.       Width           =   2940
  29.    End
  30.    Begin VB.PictureBox Pict 
  31.       AutoRedraw      =   -1  'True
  32.       BackColor       =   &H00C0C0C0&
  33.       Height          =   4440
  34.       Index           =   1
  35.       Left            =   3000
  36.       Picture         =   "ENLARGEF.frx":0446
  37.       ScaleHeight     =   292
  38.       ScaleMode       =   3  'Pixel
  39.       ScaleWidth      =   192
  40.       TabIndex        =   1
  41.       Top             =   0
  42.       Width           =   2940
  43.    End
  44.    Begin VB.PictureBox Pict 
  45.       AutoRedraw      =   -1  'True
  46.       BackColor       =   &H00C0C0C0&
  47.       Height          =   4440
  48.       Index           =   0
  49.       Left            =   0
  50.       Picture         =   "ENLARGEF.frx":088C
  51.       ScaleHeight     =   292
  52.       ScaleMode       =   3  'Pixel
  53.       ScaleWidth      =   192
  54.       TabIndex        =   0
  55.       Top             =   0
  56.       Width           =   2940
  57.    End
  58.    Begin MSComDlg.CommonDialog FileDialog 
  59.       Left            =   2760
  60.       Top             =   4200
  61.       _Version        =   65536
  62.       _ExtentX        =   847
  63.       _ExtentY        =   847
  64.       _StockProps     =   0
  65.       CancelError     =   -1  'True
  66.    End
  67.    Begin VB.Label Label1 
  68.       Alignment       =   2  'Center
  69.       Caption         =   "EnlargePicture Subroutine"
  70.       Height          =   255
  71.       Index           =   2
  72.       Left            =   6000
  73.       TabIndex        =   5
  74.       Top             =   4440
  75.       Width           =   2940
  76.    End
  77.    Begin VB.Label Label1 
  78.       Alignment       =   2  'Center
  79.       Caption         =   "PaintPicture Method"
  80.       Height          =   255
  81.       Index           =   1
  82.       Left            =   3000
  83.       TabIndex        =   4
  84.       Top             =   4440
  85.       Width           =   2940
  86.    End
  87.    Begin VB.Label Label1 
  88.       Alignment       =   2  'Center
  89.       Caption         =   "Original Image"
  90.       Height          =   255
  91.       Index           =   0
  92.       Left            =   0
  93.       TabIndex        =   3
  94.       Top             =   4440
  95.       Width           =   2940
  96.    End
  97.    Begin VB.Menu mnuFile 
  98.       Caption         =   "&File"
  99.       Begin VB.Menu mnuFileLoad 
  100.          Caption         =   "&Load..."
  101.          Shortcut        =   ^L
  102.       End
  103.       Begin VB.Menu mnuFileSep 
  104.          Caption         =   "-"
  105.       End
  106.       Begin VB.Menu mnuFileExit 
  107.          Caption         =   "E&xit"
  108.       End
  109.    End
  110.    Begin VB.Menu mnuScaleMnu 
  111.       Caption         =   "&Scale"
  112.       Enabled         =   0   'False
  113.       Begin VB.Menu mnuScale 
  114.          Caption         =   "&2x"
  115.          Checked         =   -1  'True
  116.          Index           =   2
  117.       End
  118.       Begin VB.Menu mnuScale 
  119.          Caption         =   "&3x"
  120.          Index           =   3
  121.       End
  122.       Begin VB.Menu mnuScale 
  123.          Caption         =   "&4x"
  124.          Index           =   4
  125.       End
  126.       Begin VB.Menu mnuScale 
  127.          Caption         =   "&8x"
  128.          Index           =   8
  129.       End
  130.       Begin VB.Menu mnuScale 
  131.          Caption         =   "&16x"
  132.          Index           =   16
  133.       End
  134.    End
  135. Attribute VB_Name = "EnlargeForm"
  136. Attribute VB_Creatable = False
  137. Attribute VB_Exposed = False
  138. Option Explicit
  139. Dim SysPalSize As Integer
  140. Dim NumStaticColors As Integer
  141. Dim StaticColor1 As Integer
  142. Dim StaticColor2 As Integer
  143. Dim LogPal As Integer
  144. Dim palentry(0 To 255) As PALETTEENTRY
  145. Dim wid As Long
  146. Dim hgt As Long
  147. Dim bytes() As Byte
  148. Dim ScaleFactor As Integer
  149. ' ************************************************
  150. ' Draw the enlarged images at the proper scale.
  151. ' ************************************************
  152. Sub DrawImages()
  153. Dim wid As Single
  154. Dim hgt As Single
  155. Dim x0 As Single
  156. Dim y0 As Single
  157. Dim i As Integer
  158.     WaitStart
  159.             
  160.     ' Enlarge using PaintPicture.
  161.     wid = ScaleFactor * Pict(0).ScaleWidth
  162.     hgt = ScaleFactor * Pict(0).ScaleHeight
  163.     x0 = (Pict(1).ScaleWidth - wid) / 2
  164.     y0 = (Pict(1).ScaleHeight - hgt) / 2
  165.     Pict(1).PaintPicture Pict(0).Image, _
  166.         x0, y0, wid, hgt
  167.     DoEvents
  168.     ' Enlarge using EnlargePicture.
  169.     wid = Pict(0).ScaleWidth / ScaleFactor
  170.     hgt = Pict(0).ScaleHeight / ScaleFactor
  171.     x0 = (Pict(0).ScaleWidth - wid) / 2
  172.     y0 = (Pict(0).ScaleHeight - hgt) / 2
  173.     EnlargePicture Pict(0), Pict(2), _
  174.         x0, y0, x0 + wid - 2, y0 + hgt - 2, _
  175.         0, 0, _
  176.         Pict(2).ScaleWidth - 2, _
  177.         Pict(2).ScaleHeight - 2
  178.     DoEvents
  179.     ' Let each image repair its palette if needed.
  180.     For i = 0 To 2
  181.         Pict(i).ZOrder
  182.         DoEvents
  183.     Next i
  184.     WaitEnd
  185. End Sub
  186. ' ************************************************
  187. ' Enlarge the picture in from_pic and place it
  188. ' in to_pic.
  189. ' ************************************************
  190. Sub EnlargePicture( _
  191.     ByVal from_pic As Control, ByVal to_pic As Control, _
  192.     ByVal fx1 As Integer, ByVal fy1 As Integer, _
  193.     ByVal fx2 As Integer, ByVal fy2 As Integer, _
  194.     ByVal tx1 As Integer, ByVal ty1 As Integer, _
  195.     ByVal tx2 As Integer, ByVal ty2 As Integer)
  196. Dim bm As BITMAP
  197. Dim hbm As Integer
  198. Dim status As Long
  199. Dim from_bytes() As Byte
  200. Dim to_bytes() As Byte
  201. Dim from_wid As Long
  202. Dim from_hgt As Long
  203. Dim to_wid As Long
  204. Dim to_hgt As Long
  205. Dim xscale As Single
  206. Dim yscale As Single
  207. Dim tx As Integer
  208. Dim ty As Integer
  209. Dim fx As Single
  210. Dim fy As Single
  211. Dim ifx As Single
  212. Dim ify As Single
  213. Dim dx As Single
  214. Dim dy As Single
  215. Dim c1 As Integer
  216. Dim c2 As Integer
  217. Dim c3 As Integer
  218. Dim c4 As Integer
  219. Dim i1 As Integer
  220. Dim i2 As Integer
  221. Dim clr As Integer
  222.     ' Compute the scaling parameters.
  223.     xscale = (tx2 - tx1) / (fx2 - fx1)
  224.     yscale = (ty2 - ty1) / (fy2 - fy1)
  225.     ' Get from_pic's pixels.
  226.     hbm = from_pic.Image
  227.     status = GetObject(hbm, BITMAP_SIZE, bm)
  228.     from_wid = bm.bmWidthBytes
  229.     from_hgt = bm.bmHeight
  230.     ReDim from_bytes(0 To from_wid - 1, 0 To from_hgt - 1)
  231.     status = GetBitmapBits(hbm, from_wid * from_hgt, from_bytes(0, 0))
  232.     ' Get to_pic's pixels.
  233.     hbm = to_pic.Image
  234.     status = GetObject(hbm, BITMAP_SIZE, bm)
  235.     to_wid = bm.bmWidthBytes
  236.     to_hgt = bm.bmHeight
  237.     ReDim to_bytes(0 To to_wid - 1, 0 To to_hgt - 1)
  238.     status = GetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
  239.         
  240.     ' Perform the enlargement.
  241.     For ty = ty1 To ty2
  242.         fy = (ty - ty1) / yscale + fy1
  243.         ify = Int(fy)
  244.         dy = fy - ify
  245.         For tx = tx1 To tx2
  246.             fx = (tx - tx1) / xscale + fx1
  247.             ifx = Int(fx)
  248.             dx = fx - ifx
  249.             ' Interpolate using the four nearest
  250.             ' pixels in from_pic.
  251.             c1 = palentry(from_bytes(ifx, ify)).peRed
  252.             c2 = palentry(from_bytes(ifx + 1, ify)).peRed
  253.             c3 = palentry(from_bytes(ifx, ify + 1)).peRed
  254.             c4 = palentry(from_bytes(ifx + 1, ify + 1)).peRed
  255.             ' Interpolate in the Y direction.
  256.             i1 = c1 * (1 - dy) + c3 * dy
  257.             i2 = c2 * (1 - dy) + c4 * dy
  258.             ' Interpolate the results in the X direction.
  259.             clr = i1 * (1 - dx) + i2 * dx
  260.             to_bytes(tx, ty) = NearestNonstaticGray(clr)
  261.         Next tx
  262.     Next ty
  263.     ' Update from_pic.
  264.     status = SetBitmapBits(hbm, to_wid * to_hgt, to_bytes(0, 0))
  265.     to_pic.Refresh
  266. End Sub
  267. ' ***********************************************
  268. ' Load the control's palette so the non-static
  269. ' colors are grays. Map the logical palette to
  270. ' match the system palette. Convert the image to
  271. ' use the non-static grays.
  272. ' Set the following module global variables.
  273. '   LogPal      Image logical palette handle.
  274. '   palentry()  Image logical palette entries.
  275. '   wid         Width of image.
  276. '   hgt         Height of image.
  277. '   bytes(1 To wid, 1 To hgt)
  278. '               Image pixel values.
  279. ' ***********************************************
  280. Sub MatchGrayPalette(pic As Control)
  281. Dim sys(0 To 255) As PALETTEENTRY
  282. Dim i As Integer
  283. Dim bm As BITMAP
  284. Dim hbm As Integer
  285. Dim status As Long
  286. Dim X As Integer
  287. Dim Y As Integer
  288. Dim gray As Single
  289. Dim dgray As Single
  290. Dim c As Integer
  291. Dim clr As Integer
  292.     ' Make sure pic has the foreground palette.
  293.     pic.ZOrder
  294.     i = RealizePalette(pic.hdc)
  295.     DoEvents
  296.     ' Get the system palette entries.
  297.     i = GetSystemPaletteEntries(pic.hdc, 0, SysPalSize, sys(0))
  298.         
  299.     ' Get the image pixels.
  300.     hbm = pic.Image
  301.     status = GetObject(hbm, BITMAP_SIZE, bm)
  302.     wid = bm.bmWidthBytes
  303.     hgt = bm.bmHeight
  304.     ReDim bytes(1 To wid, 1 To hgt)
  305.     status = GetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  306.     ' Make the logical palette as big as possible.
  307.     LogPal = pic.Picture.hPal
  308.     If ResizePalette(LogPal, SysPalSize) = 0 Then
  309.         Beep
  310.         MsgBox "Error resizing logical palette.", _
  311.             vbExclamation
  312.         Exit Sub
  313.     End If
  314.     ' Blank the non-static colors.
  315.     For i = 0 To StaticColor1
  316.         palentry(i) = sys(i)
  317.     Next i
  318.     For i = StaticColor1 + 1 To StaticColor2 - 1
  319.         With palentry(i)
  320.             .peRed = 0
  321.             .peGreen = 0
  322.             .peBlue = 0
  323.             .peFlags = PC_NOCOLLAPSE
  324.         End With
  325.     Next i
  326.     For i = StaticColor2 To 255
  327.         palentry(i) = sys(i)
  328.     Next i
  329.     i = SetPaletteEntries(LogPal, 0, SysPalSize, palentry(0))
  330.     ' Insert the non-static grays.
  331.     gray = 0
  332.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  333.     For i = StaticColor1 + 1 To StaticColor2 - 1
  334.         c = gray
  335.         gray = gray + dgray
  336.         With palentry(i)
  337.             .peRed = c
  338.             .peGreen = c
  339.             .peBlue = c
  340.         End With
  341.     Next i
  342.     i = SetPaletteEntries(LogPal, StaticColor1 + 1, StaticColor2 - StaticColor1 - 1, palentry(StaticColor1 + 1))
  343.     ' Recreate the image using the new colors.
  344.     For Y = 1 To hgt
  345.         For X = 1 To wid
  346.             clr = bytes(X, Y)
  347.             With sys(clr)
  348.                 c = (CInt(.peRed) + .peGreen + .peBlue) / 3
  349.             End With
  350.             bytes(X, Y) = NearestNonstaticGray(c)
  351.         Next X
  352.     Next Y
  353.     status = SetBitmapBits(hbm, wid * hgt, bytes(1, 1))
  354.     ' Realize the gray palette.
  355.     i = RealizePalette(pic.hdc)
  356.     pic.Refresh
  357. End Sub
  358. ' ************************************************
  359. ' Return the index of the nonstatic gray closest
  360. ' to the given value (assuming the non-static
  361. ' colors are a gray scale created by
  362. ' MatchGrayPalette).
  363. ' ************************************************
  364. Function NearestNonstaticGray(c As Integer) As Integer
  365. Dim dgray As Single
  366.     If c < 0 Then
  367.         c = 0
  368.     ElseIf c > 255 Then
  369.         c = 255
  370.     End If
  371.     dgray = 255 / (StaticColor2 - StaticColor1 - 2)
  372.     NearestNonstaticGray = c / dgray + StaticColor1 + 1
  373. End Function
  374. Private Sub Form_Load()
  375. Dim i As Integer
  376.     ' Make sure the screen supports palettes.
  377.     If Not GetDeviceCaps(hdc, RASTERCAPS) And RC_PALETTE Then
  378.         Beep
  379.         MsgBox "This monitor does not support palettes.", _
  380.             vbCritical
  381.         End
  382.     End If
  383.     ' Get system palette size and # static colors.
  384.     SysPalSize = GetDeviceCaps(hdc, SIZEPALETTE)
  385.     NumStaticColors = GetDeviceCaps(hdc, NUMRESERVED)
  386.     StaticColor1 = NumStaticColors \ 2 - 1
  387.     StaticColor2 = SysPalSize - NumStaticColors \ 2
  388.     ' Make the pictures all use gray palettes.
  389.     ScaleFactor = 2
  390.     Me.Show
  391.     DoEvents
  392.     WaitStart
  393.     For i = 1 To 2
  394.         MatchGrayPalette Pict(i)
  395.     Next i
  396.     DoEvents
  397.     ' Let each image repair its palette if needed.
  398.     For i = 0 To 2
  399.         Pict(i).ZOrder
  400.         DoEvents
  401.     Next i
  402.     WaitEnd
  403. End Sub
  404. ' ***********************************************
  405. ' Reset the cursors for the form and all the
  406. ' picture boxes.
  407. ' ***********************************************
  408. Sub WaitEnd()
  409. Dim i As Integer
  410.     MousePointer = vbDefault
  411.     For i = 0 To 2
  412.         Pict(i).MousePointer = vbDefault
  413.     Next i
  414. End Sub
  415. ' ***********************************************
  416. ' Give the form and all the picture boxes an
  417. ' hourglass cursor.
  418. ' ***********************************************
  419. Sub WaitStart()
  420. Dim i As Integer
  421.     MousePointer = vbHourglass
  422.     For i = 0 To 2
  423.         Pict(i).MousePointer = vbHourglass
  424.     Next i
  425.     DoEvents
  426. End Sub
  427. Private Sub Form_Unload(Cancel As Integer)
  428.     End
  429. End Sub
  430. Private Sub mnuFileExit_Click()
  431.     Unload Me
  432. End Sub
  433. ' ***********************************************
  434. ' Load a new image file.
  435. ' ***********************************************
  436. Private Sub mnuFileLoad_Click()
  437. Dim fname As String
  438.     ' Allow the user to pick a file.
  439.     On Error Resume Next
  440.     FileDialog.filename = "*.BMP;*.ICO;*.RLE;*.WMF;*.DIB"
  441.     FileDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  442.     FileDialog.ShowOpen
  443.     If Err.Number = cdlCancel Then
  444.         Exit Sub
  445.     ElseIf Err.Number <> 0 Then
  446.         Beep
  447.         MsgBox "Error selecting file.", , vbExclamation
  448.         Exit Sub
  449.     End If
  450.     On Error GoTo 0
  451.     fname = Trim$(FileDialog.filename)
  452.     FileDialog.InitDir = Left$(fname, Len(fname) _
  453.         - Len(FileDialog.FileTitle) - 1)
  454.     ' Load the picture.
  455.     WaitStart
  456.     LoadFromPict fname
  457.     mnuScaleMnu.Enabled = True
  458.     mnuScale_Click 2
  459.     WaitEnd
  460. End Sub
  461. ' ***********************************************
  462. ' Load the indicated file and prepare to work
  463. ' with its palette.
  464. ' ***********************************************
  465. Sub LoadFromPict(fname As String)
  466. Dim status As Long
  467.     On Error GoTo LoadFileError
  468.     Pict(0).Picture = LoadPicture(fname)
  469.     On Error GoTo 0
  470.         
  471.     MatchGrayPalette Pict(0)
  472.     Caption = "Enlarge [" & fname & "]"
  473.     Exit Sub
  474. LoadFileError:
  475.     Beep
  476.     MsgBox "Error loading file " & fname & "." & _
  477.         vbCrLf & Error$
  478.     Exit Sub
  479. End Sub
  480. ' ************************************************
  481. ' Redraw the images at the new scale.
  482. ' ************************************************
  483. Private Sub mnuScale_Click(Index As Integer)
  484.     mnuScale(ScaleFactor).Checked = False
  485.     ScaleFactor = Index
  486.     mnuScale(ScaleFactor).Checked = True
  487.     DrawImages
  488. End Sub
  489.